home *** CD-ROM | disk | FTP | other *** search
VERSION 4.00 Begin VB.Form frmBulkMail Caption = "Bulk Mail Distribution" ClientHeight = 6540 ClientLeft = 1245 ClientTop = 1560 ClientWidth = 8955 Height = 6945 Icon = "frmMail.frx":0000 Left = 1185 LinkTopic = "Form1" LockControls = -1 'True ScaleHeight = 6540 ScaleWidth = 8955 Top = 1215 Width = 9075 Begin VB.PictureBox SizeBar BorderStyle = 0 'None Height = 5805 Left = 3390 MousePointer = 9 'Size W E ScaleHeight = 5805 ScaleWidth = 30 TabIndex = 14 Top = 390 Width = 25 End Begin VB.Timer tmrStatus Left = 9000 Top = 690 End Begin TabDlg.SSTab tabMail Height = 5805 Left = 3420 TabIndex = 15 Top = 390 Width = 5535 _Version = 65536 _ExtentX = 9763 _ExtentY = 10239 _StockProps = 15 Caption = "(SMTP) Send Mail" TabsPerRow = 3 Tab = 0 TabOrientation = 0 Tabs = 3 Style = 1 TabMaxWidth = 0 TabHeight = 520 TabCaption(0) = "(SMTP) Send Mail" Tab(0).ControlCount= 9 Tab(0).ControlEnabled= -1 'True Tab(0).Control(0)= "Label1(2)" Tab(0).Control(1)= "Label1(0)" Tab(0).Control(2)= "txtBody" Tab(0).Control(3)= "txtTo" Tab(0).Control(4)= "txtCc" Tab(0).Control(5)= "txtSubject" Tab(0).Control(6)= "cmdTo" Tab(0).Control(7)= "cmdCc" Tab(0).Control(8)= "txtFrom" TabCaption(1) = "(POP 3) Inbound Mail" Tab(1).ControlCount= 6 Tab(1).ControlEnabled= 0 'False Tab(1).Control(0)= "txtMessage" Tab(1).Control(1)= "txtMessageNumber" Tab(1).Control(2)= "mailSpooler" Tab(1).Control(3)= "Label1(7)" Tab(1).Control(4)= "lblMessageCount" Tab(1).Control(5)= "Label1(8)" TabCaption(2) = "Connection Options" Tab(2).ControlCount= 2 Tab(2).ControlEnabled= 0 'False Tab(2).Control(0)= "Frame1(1)" Tab(2).Control(1)= "Frame1(0)" Begin VB.Frame Frame1 Caption = "POP3" Height = 1155 Index = 1 Left = -74880 TabIndex = 25 Top = 1500 Width = 3405 Begin VB.TextBox txtPOP3Password Height = 285 Left = 990 PasswordChar = "*" TabIndex = 10 Top = 780 Width = 2295 End Begin VB.TextBox txtPOP3Username Height = 285 Left = 990 TabIndex = 9 Top = 480 Width = 2295 End Begin VB.TextBox txtPOP3Server Height = 285 Left = 990 TabIndex = 8 Top = 180 Width = 2295 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Password:" Height = 195 Index = 6 Left = 240 TabIndex = 28 Top = 840 Width = 735 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Username:" Height = 195 Index = 5 Left = 210 TabIndex = 27 Top = 540 Width = 765 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Server:" Height = 195 Index = 4 Left = 450 TabIndex = 26 Top = 240 Width = 510 End End Begin VB.Frame Frame1 Caption = "SMTP" Height = 945 Index = 0 Left = -74880 TabIndex = 23 Top = 420 Width = 3405 Begin VB.TextBox txtSMTPServer Height = 285 Left = 990 TabIndex = 7 Top = 240 Width = 2295 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Server:" Height = 195 Index = 3 Left = 450 TabIndex = 24 Top = 300 Width = 510 End End Begin VB.TextBox txtMessage Height = 4725 Left = -74970 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 6 Top = 1020 Width = 5415 End Begin VB.TextBox txtMessageNumber Height = 285 Left = -73455 TabIndex = 5 Text = "1" Top = 660 Width = 675 End Begin VB.Timer mailSpooler Left = -71745 Top = 480 End Begin VB.TextBox txtFrom Height = 285 Left = 870 TabIndex = 3 Top = 945 Width = 3735 End Begin VB.CommandButton cmdCc Caption = "&Cc" Height = 255 Left = 90 TabIndex = 17 TabStop = 0 'False Top = 675 Width = 705 End Begin VB.CommandButton cmdTo Caption = "&To" Height = 255 Left = 90 TabIndex = 16 TabStop = 0 'False Top = 375 Width = 705 End Begin VB.TextBox txtSubject Height = 285 Left = 870 TabIndex = 2 Top = 1245 Width = 3735 End Begin VB.TextBox txtCc Height = 285 Left = 870 TabIndex = 1 Top = 645 Width = 3735 End Begin VB.TextBox txtTo Height = 285 Left = 870 TabIndex = 0 Top = 345 Width = 3735 End Begin VB.TextBox txtBody Height = 4155 HideSelection = 0 'False Left = 45 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 4 Top = 1575 Width = 5415 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Message Count:" Height = 195 Index = 7 Left = -74880 TabIndex = 22 Top = 390 Width = 1155 End Begin VB.Label lblMessageCount Caption = "0" Height = 165 Left = -73410 TabIndex = 21 Top = 420 Width = 765 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "Message Number:" Height = 195 Index = 8 Left = -74895 TabIndex = 20 Top = 690 Width = 1290 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "&From:" Height = 195 Index = 0 Left = 390 TabIndex = 18 Top = 1005 Width = 390 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "&Subject:" Height = 195 Index = 2 Left = 210 TabIndex = 11 Top = 1305 Width = 585 End End Begin ComctlLib.Toolbar Tools Align = 1 'Align Top Height = 390 Left = 0 TabIndex = 19 Top = 0 Width = 8955 _Version = 65536 _ExtentX = 15796 _ExtentY = 688 _StockProps = 96 ImageList = "imgButtons" NumButtons = 11 i1 = "frmMail.frx":0442 i2 = "frmMail.frx":05E1 i3 = "frmMail.frx":0794 i4 = "frmMail.frx":094B i5 = "frmMail.frx":0AEA i6 = "frmMail.frx":0C91 i7 = "frmMail.frx":0E5C i8 = "frmMail.frx":0FFB i9 = "frmMail.frx":11B6 i10 = "frmMail.frx":1391 i11 = "frmMail.frx":1531 AlignSet = -1 'True End Begin POPCTLib.POPCT POPCT Left = 9000 Top = 2970 _ExtentX = 847 _ExtentY = 847 RemoteHost = "127.0.0.1" RemotePort = 110 ConnectTimeout = 0 RecvTimeout = 0 NotificationMode= 1 UserId = "" Password = "" TopLines = 49 End Begin SMTPCTLib.smtpct SMTPCT Left = 9000 Top = 2340 _ExtentX = 847 _ExtentY = 847 RemoteHost = "mail" RemotePort = 25 ConnectTimeout = 0 RecvTimeout = 0 NotificationMode= 0 End Begin ComctlLib.ImageList imgTree Left = 9000 Top = 1740 _Version = 65536 _ExtentX = 1005 _ExtentY = 1005 _StockProps = 1 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 NumImages = 3 i1 = "frmMail.frx":170D i2 = "frmMail.frx":1C04 i3 = "frmMail.frx":1E03 End Begin ComctlLib.ImageList imgButtons Left = 9000 Top = 1140 _Version = 65536 _ExtentX = 1005 _ExtentY = 1005 _StockProps = 1 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 NumImages = 7 i1 = "frmMail.frx":22FA i2 = "frmMail.frx":26B9 i3 = "frmMail.frx":2A78 i4 = "frmMail.frx":2C77 i5 = "frmMail.frx":2E76 i6 = "frmMail.frx":3235 i7 = "frmMail.frx":35F4 End Begin ComctlLib.StatusBar Status Align = 2 'Align Bottom Height = 345 Left = 0 TabIndex = 13 Top = 6195 Width = 8955 _Version = 65536 _ExtentX = 15796 _ExtentY = 609 _StockProps = 68 AlignSet = -1 'True SimpleText = "" _timers = 2 NumPanels = 5 i1 = "frmMail.frx":37F3 i2 = "frmMail.frx":3921 i3 = "frmMail.frx":3A4F i4 = "frmMail.frx":3B5B i5 = "frmMail.frx":3CAB End Begin ComctlLib.TreeView Tree Height = 5805 Left = 0 TabIndex = 12 TabStop = 0 'False Top = 390 Width = 3375 _Version = 65536 _ExtentX = 5953 _ExtentY = 10239 _StockProps = 196 Appearance = 1 BorderStyle = 1 HideSelection = 0 'False ImageList = "imgTree" Indentation = 441 LabelEdit = 1 PathSeparator = "\" Style = 7 End Attribute VB_Name = "frmBulkMail" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Public CurrentNode As Node Public Addresses As String '------------------------------------------------------------ Private Sub cmdCc_Click() '------------------------------------------------------------ Dim NodeC As Node '------------------------------------------------------------ If (CurrentNode.Key = MAILGROUPROOT) Then Exit Sub If (CurrentNode.Children > 0) Then Set NodeC = CurrentNode.Child Do ' txtCc.Text = txtCc.Text & NodeC.Text & ", " txtCc.Text = NodeC.Text Set NodeC = NodeC.Next Loop Until (NodeC Is Nothing) ' While Child Nodes Exist Else ' txtCc.Text = txtCc.Text & CurrentNode.Text & ", " txtCc.Text = CurrentNode.Text End If '------------------------------------------------------------ End Sub '------------------------------------------------------------ '------------------------------------------------------------ Private Sub cmdTo_Click() '------------------------------------------------------------ Dim NodeC As Node '------------------------------------------------------------ If (CurrentNode.Key = MAILGROUPROOT) Then Exit Sub If (CurrentNode.Children > 0) Then Set NodeC = CurrentNode.Child Do ' txtTo.Text = txtTo.Text & NodeC.Text & ", " txtTo.Text = NodeC.Text Set NodeC = NodeC.Next Loop Until (NodeC Is Nothing) ' While Child Nodes Exist Else ' txtTo.Text = txtTo.Text & CurrentNode.Text & ", " txtTo.Text = CurrentNode.Text End If '------------------------------------------------------------ End Sub '------------------------------------------------------------ '------------------------------------------------------------ Private Sub Form_Load() '------------------------------------------------------------ Dim aPath As String '------------------------------------------------------------ aPath = App.Path If (Left(aPath, 1) <> "\") Then aPath = aPath & "\" Addresses = aPath & ADDRESSBOOK Call BuildDatabase(Addresses, sqlSCRIPT1, sqlSCRIPT2) ' If database does not exist then create it... Set CurrentNode = Tree.Nodes.Add(, , MAILGROUPROOT, MAILGROUPROOT, icoROOT) Call AddAliasesToTree(Tree, Addresses) CurrentNode.Expanded = True CurrentNode.Selected = True Status.Panels.Item(pnlPOPSTATE).Text = POPCT.StateString Status.Panels.Item(pnlSMTPSTATE).Text = smtpct.StateString '------------------------------------------------------------ End Sub '------------------------------------------------------------ '------------------------------------------------------------ Private Sub Form_Resize() '------------------------------------------------------------ Dim W As Long Dim H As Long Dim BDR As Long '------------------------------------------------------------ H = Abs(Me.ScaleHeight - Status.Height - Tools.Height) Tree.Height = H SizeBar.Height = H BDR = 2 * SizeBar.Width W = Abs(Me.ScaleWidth - SizeBar.Left - SizeBar.Width) tabMail.Move tabMail.Left, tabMail.Top, W, H With txtBody .Move .Left, .Top, Abs(W - (2 * BDR)), Abs(H - .Top - BDR) End With With txtMessage .Move .Left, .Top, Abs(W - (2 * BDR)), Abs(H - .Top - BDR) End With '------------------------------------------------------------ End Sub '------------------------------------------------------------ Private Sub lblMessageCount_Click() lblMessageCount.Caption = Format(POPCT.MessageCount, "0") End Sub Private Sub mailSpooler_Timer() If ((POPCT.State = prcConnected) And _ (POPCT.ProtocolState = prcTransaction) And _ (POPCT.MessageCount > 0)) Then POPCT.RetrieveMessage 1 End If End Sub Private Sub POPCT_Authenticate() Status.Panels.Item(pnlPOPSTATE).Text = "Authenticated" lblMessageCount.Caption = Format(POPCT.MessageCount, "0") Tools.Buttons(tbSTARTTIMER).Enabled = True Tools.Buttons(tbRECEIVEMAIL).Enabled = True End Sub Private Sub POPCT_DocOutput(ByVal DocOutput As DocOutput) Dim msg As Variant Select Case DocOutput.State Case icDocBegin Debug.Print "POPCT: Download Started." txtMessage.Text = "" Case icDocHeaders Debug.Print "POPCT: Downloading Headers...", DocOutput.Headers.Count Dim x As DocHeader For Each x In DocOutput.Headers Debug.Print "Header: " & x.Name, x.Value Next Case icDocData DocOutput.GetData msg Debug.Print "POPCT: Downloading Data..." txtMessage.Text = txtMessage.Text & msg Case icDocEnd Dim Group As String, Alias As String Debug.Print "POPCT: Download Complete." If (ParseMessage(txtMessage.Text, Group, Alias)) Then Call AddAliasToDatabase(Addresses, Group, Alias) Call AddAliasesToTree(Tree, Addresses) Debug.Print "ParseMessage:Success" Else Debug.Print "ParseMessage:Error" End If POPCT.Delete 1 ' Delete message that just finished downloading POPCT.Reset ' Update mail message list... Case icDocError Case icDocNone Case Else End Select End Sub Private Sub POPCT_Error(Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean) ' Debug.Print "POPCT Error:" ' Debug.Print "Number:", Number ' Debug.Print "Description:", Description ' Debug.Print "Scode:", Hex$(Scode) ' Debug.Print "Source:", Source End Sub Private Sub POPCT_ProtocolStateChanged(ByVal ProtocolState As Integer) Debug.Print "POPCT: ProtocolState: " & POPCT.ProtocolStateString Select Case ProtocolState Case prcNone Case prcAuthorization 'POPCT.UserId = txtPOP3Username.Text 'POPCT.Password = txtPOP3Password.Text 'POPCT.Authenticate POPCT.Authenticate txtPOP3Username.Text, txtPOP3Password.Text Case prcTransaction Case prcUpdate End Select End Sub Private Sub POPCT_StateChanged(ByVal State As Integer) Status.Panels.Item(pnlPOPSTATE).Text = POPCT.StateString Select Case State Case prcConnecting, prcConnected Case prcDisconnecting, prcDisconnected Tools.Buttons(tbSTARTTIMER).Enabled = False Tools.Buttons(tbRECEIVEMAIL).Enabled = False mailSpooler.Interval = 0 ' Set mailspooler to 1 minute lblMessageCount.Caption = "0" Case Else End Select End Sub '------------------------------------------------------------ Private Sub SizeBar_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single) '------------------------------------------------------------ If (Button = vbLeftButton) Then ' If Left Button Down SizeBar.Left = SizeBar.Left + x ' Move Size Bar Me.Refresh ' Refresh improves appearence End If '------------------------------------------------------------ End Sub '------------------------------------------------------------ '------------------------------------------------------------ Private Sub SizeBar_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) '------------------------------------------------------------ Dim L As Long, W As Long, SW As Long Dim L2 As Long, W2 As Long '------------------------------------------------------------ With SizeBar L = .Left W = .Width SW = Me.ScaleWidth If (L < W) Then ' Outside Left Of Window L = W ' Fix Position .Left = L ' Adjust sizebar position ElseIf (L > SW) Then ' Outside Right Of Window L = SW - W ' Fix Position .Left = L ' Adjust sizebar position End If Tree.Width = Abs(L - Tree.Left) ' Resize TreeView Width L2 = L + W W2 = Abs(SW - L - W) tabMail.Move L2, tabMail.Top, W2 txtBody.Width = Abs(W2 - (4 * W)) txtMessage.Width = txtBody.Width End With '------------------------------------------------------------ End Sub '------------------------------------------------------------ Private Sub smtpct_DocInput(ByVal DocInput As DocInput) Select Case DocInput.State Case icDocBegin Debug.Print "SMTPCT: Send Start." Case icDocHeaders Debug.Print "SMTPCT: Sending Headers..." Case icDocData Debug.Print "SMTPCT: Sending Data..." Case icDocEnd Debug.Print "SMTPCT: Send Complete." Case icDocError Case icDocNone End Select End Sub Private Sub smtpct_Error(Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean) ' Debug.Print "SMTPCT Error:" ' Debug.Print "Number:", Number ' Debug.Print "Description:", Description ' Debug.Print "Scode:", Hex$(Scode) ' Debug.Print "Source:", Source End Sub Private Sub smtpct_ProtocolStateChanged(ByVal ProtocolState As Integer) Debug.Print "SMTPCT: ProtocolState: " & smtpct.ProtocolStateString End Sub Private Sub SMTPCT_StateChanged(ByVal State As Integer) Status.Panels.Item(pnlSMTPSTATE).Text = smtpct.StateString End Sub '------------------------------------------------------------ Private Sub Tools_ButtonClick(ByVal Button As Button) '------------------------------------------------------------ Select Case Button.Index Case tbCONNECT POPCT.RemoteHost = txtPOP3Server.Text POPCT.UserId = txtPOP3Username.Text POPCT.Password = txtPOP3Password.Text POPCT.Connect Case tbDISCONNECT POPCT.Quit Case tbSENDMAIL Dim HDRs As DocHeaders smtpct.RemoteHost = txtSMTPServer.Text Set HDRs = smtpct.DocInput.Headers HDRs.Clear HDRs.Add "To", txtTo.Text HDRs.Add "CC", txtCc.Text HDRs.Add "From", txtFrom.Text HDRs.Add "Subject", txtSubject.Text HDRs.Add "Message-Id", "<" & App.Title & _ "." & Format(Date) & _ "." & Format(Timer) & _ "." & txtFrom.Text & ">" HDRs.Add "Content-Type", "TEXT/PLAIN; charset=US-ASCII" HDRs.Add "Content-Length", " " & Len(txtBody.Text) + 2 smtpct.SendDoc , HDRs, txtBody.Text Case tbRECEIVEMAIL POPCT.RetrieveMessage Val(txtMessageNumber.Text) Case tbADDALIAS Load frmAddAlias If (CurrentNode.Image = icoGROUP) Then frmAddAlias.txtGroup.Text = CurrentNode.Text frmAddAlias.Show vbModal Case tbDELALIAS Call DeleteAliases(Tree, Addresses) Case tbSTARTTIMER If (Button.Value = tbrPressed) Then mailSpooler.Interval = 60000 Else mailSpooler.Interval = 0 End If Case Else End Select '------------------------------------------------------------ End Sub '------------------------------------------------------------ Private Sub Tree_NodeClick(ByVal Node As Node) Set CurrentNode = Node Tools.Buttons(tbDELALIAS).Enabled = (Node.Key <> MAILGROUPROOT) End Sub 
(.txt)